perm filename OLDMAT[PAT,LMM] blob
sn#056042 filedate 1973-07-30 generic text, type T, neo UTF8
(FILECREATED "30-JUL-73 18:00:28" OLDMATCH)
(DEFINEQ
(PACKLDIFF
[LAMBDA (L TAIL)
(PROG (TEM)
(IF TEM←(NLEFT L 1 TAIL)
THEN TEM::1←NIL
(PROG1 (PACK L)
TEM::1←TAIL])
(MAKE!DEFAULT
[LAMBDA (PAT)
(SELECTQ VARDEFAULT
((← SETQ SET)
(FRPLACA PAT <'← PAT:2::1 ! '$ >)
(FRPLACD PAT PAT::2))
((QUOTE ')
(FRPLACA PAT:2 '')
(BI12 PAT))
((= EQUAL)
(FRPLACA PAT:2 '=)
(BI12 PAT))
(HELP '"FUNNY VARDEFAULT"])
(PARSE
[LAMBDA (X)
(PATPARSE (COPY X])
('LDIFF
[LAMBDA (A B) <'LDIFF A B>])
('TAILP
[LAMBDA (X Y) <'TAILP X Y>])
('LENGTH
[LAMBDA (EXPR)
(LIST (QUOTE LENGTH)
EXPR])
(OPTIMIZEAND
[LAMBDA (EXPRESSION)
(* NOTE: NEEDS TO BE ADDED -
('AND $ !X← ('OR & 'T) $ !Y←}
('OR & T) $) -
-
GOES TO -
-
<'COND < (LDIFF VAR X) ! (MAPCAR
(LDIFF X Y) 'CADR) <'AND !Y>>>)
(PROG ((LIS EXPRESSION))
LP (IF LIS::1=NIL
THEN (RETURN (IF EXPRESSION::2
THEN EXPRESSION
ELSE EXPRESSION:2))
ELSEIF LIS:2=NIL or LIS:2=T
THEN (LIS::1←LIS::2)
ELSEIF NLISTP LIS:2
THEN (LIS::2←(DREMOVE LIS:2 LIS::2))
ELSEIF LIS:2:1='SETQ
THEN DREMOVE LIS:2:2 LIS::1
ELSEIF LIS:2:1='AND
THEN LIS::1←<!!
LIS:2::1 ! LIS::2> (GO LP))
(LIS←LIS::1)
(GO LP])
('!AND
[LAMBDA (EXPRLIST)
(OPTIMIZEAND <'AND ! EXPRLIST>])
('SOME
[LAMBDA (LST ARGS EXPR) <'SOME LST <'FUNCTION <'LAMBDA ARGS EXPR>>>])
('SETVAR
[LAMBDA (VAR EXPR LOCALORSETQFLG)
(IF VAR and VAR}=T
THEN (IF POSTPONE←SIDE←EFFECTS and (LOCALPATVAR VAR)
THEN ('SETQ VAR EXPR LOCALORSETQFLG)
ELSEIF EASYTORECOMPUTE EXPR
THEN (POSTPONE ('SETQ VAR EXPR)) EXPR
ELSE (PROG (TEM)
(POSTPONE ('SETQ VAR TEM←(MAKEVAR T)))
('SETQ TEM EXPR LOCALORSETQFLG)))
ELSE EXPR])
('REPLACE←SIDE←EFFECT
[LAMBDA (VAR VALUE)
(COND
[(SETQ TEM (EASYTORECOMPUTE VAR))
(COND
((BOUNDVAR TEM)
(POSTPONE ('REPLACE VAR VALUE))
T)
(T (POSTPONE ('REPLACE (SUBST (SETQ TEM2 (MAKEVAR T))
TEM VAR)
VALUE))
('SETQ TEM2 TEM]
(T (PROG (TEM2 (TEM ('REPLACE VAR VALUE)))
(PROG1 ('SETQ (SETQ TEM2 (MAKEVAR T))
(CADR TEM))
(RPLACA (CDR TEM)
TEM2)
(POSTPONE TEM])
('SETQ←SIDE←EFFECT
[LAMBDA (LOCALVAR VALUE LOCALORSETQFLG TSTPAT)
(* THE SETQ IS either placed IN line, or postponed -
'SETQ←SIDE←EFFECT decides -
However, even if it IS postponed, it may be necc to
set a temp variable -
THE args to 'SETQ←SIDE←EFFECT are: -
Localvar to be set -
Value it IS to get -
Orsetq if necc flag -
Pattern to check CANMATCHNIL for THE orsetq test -
It may reset THE value of "VAR" to THE new localvar)
(COND
[(OR (NOT POSTPONE←SIDE←EFFECTS)
(LOCALPATVAR LOCALVAR))
(SETQ VAR LOCALVAR)
('SETQ LOCALVAR VALUE (AND LOCALORSETQFLG (OR (NULL TSTPAT)
(CANMATCHNIL
TSTPAT]
(T (POSTPONE ('SETQ LOCALVAR VALUE))
T])
(MAKEVAR
[LAMBDA (X)
(COND
((EQ X T)
(BIND (SETQ X (GENSYML X)))
X)
(T X])
(BOUNDVAR
[LAMBDA (X)
(AND X (NOT (FMEMB X SOMEVARS])
(BIND
[LAMBDA (VAR)
(SETQ BINDINGS (CONS VAR BINDINGS))
VAR])
(EQTOMEMB
[LAMBDA (EXPR)
(<(SELECTQ (EXPR : 1)
(EQUAL 'MEMBER)
(EQ 'MEMB)
(HELP '"BAD EQ EXPR IN EQTOMEMB" EXPR))
EXPR:3 EXPR:2>])
(NOMATCHARBCAR?
[LAMBDA (PAT)
(AND PAT (OR (NOMATCHARB? PAT:1)
(AND (OR PAT:1:1='!-> PAT:1:1='!←)
(NOMATCHARBCAR? PAT::1])
(SUBPAT?
[LAMBDA (PATELT)
(AND (LISTP PATELT)
(NOT (FMEMB (CAR PATELT)
(QUOTE (! $$ DEFAULT = == ' : ANY ← -> → <-])
(NOMATCHELT?
[LAMBDA (PAT)
(PROG (MATCH SETS)
(IF (ANAL!PAT PAT)='ARB
THEN }MATCH])
(MEMBPAT?
[LAMBDA (PAT) (* Can a MEMB be used
for pat?)
(AND (FMEMB PAT:1:1 '(' = ==))
(PROG (SETS MATCH TEM3 (PAT2 PAT::1))
(* Check if PAT ends is ($ 'foo nomatch nomatch ...
Arb-nomatch ...))
LP (IF PAT2=NIL
THEN (RETURN)
ELSEIF (TEM3←(ANALPATELT PAT2:1)='ELT
or (NUMBERP TEM3))
and MATCH=NIL
THEN PAT2←PAT2::1
ELSEIF MATCH=NIL and TEM3='ARB
THEN RETURN PAT2
ELSE (RETURN))
(GO LP])
(SKIP$
[LAMBDA (PAT SETOK MATCHOK TAIL)
(* SCANS PAT UNTIL ONE OF THE FOLLOWING CONDITIONS
OCCURS: -
(1) TAIL IS HIT -
(2) A PATTERN ELEMENT WHICH MATCHES AN ARBITRARY
LENGTH SEGMENT IS HIT -
(3) SETOK IS NIL AND A PATTERN ELMENT INVOLVING A ←
IS HIT -
(4) MATCHOK IS NIL AND A PATTERN ELMENT INVOLVING A
"MATCH" OF ANYKIND IS HIT -
(5) THE END OF PAT IS REACHED)
(* The free variables SETS and MATCH are set to T if
a set or MATCH (respectively) are found in any of
the pattern elements passed over)
(PROG (OLDSET OLDMATCH)
LP (OLDSET←SETS)
(OLDMATCH←MATCH)
(IF PAT=NIL or PAT=TAIL
THEN RETURN PAT
ELSEIF TEM←(ANALPATELT PAT:1 T)='ARB or }SETOK
and SETS
or }MATCHOK
and MATCH
THEN SETS←OLDSET
MATCH←OLDMATCH
(RETURN PAT)
ELSE LEN←('PLUS TEM LEN))
(PAT←PAT::1)
(GO LP])
(ANAL!PAT
[LAMBDA (PAT SEGEXPR)
(IF NLISTP PAT
THEN (SELECTQ PAT
(("*" *) (* !* is like result←$)
SETS←T
'ARB)
(($1 &) (* !$1 is the same as $)
'ARB)
(HELP '"FUNNY NLISTP PAT AFTER ! IN" PAT))
ELSE (SELECTQ PAT:1
(' (* !'exp matches exactly
length exp things)
(LENGTH PAT::1))
((= ==) (* = exp matches
precomputable NUMBER of
things)
MATCH←T
(* THIS ISWHAT USED TO BE HERE:
(COND (SEGEXPR ('LENGTH (CDR PAT)))
(T (QUOTE SEG))))
'ARB)
(: MATCH←T
'ARB)
((← ->)
SETS←T
(ANAL!PAT PAT::2))
(DEFAULT (* MAKEDEFAULT actually
smashes it, so go ahead
& try it again)
(MAKEDEFAULT PAT)
(ANAL!PAT PAT SEGEXPR))
(ANY
(* ! (any ...) matches the MAX of ANAL!PAT of the
elts of the any)
(ANALPAT PAT::1 (AND SEGEXPR 'SEGEXPR)
(FUNCTION ANAL!PAT)))
(PROGN
(* Otherwise, there is a !
(PAT) so it's the MAX, except if there are all fixed
segs, add'em up)
(ANALPAT PAT
(IF SEGEXPR
THEN 'SEGEXPR
ELSE T)
NIL NIL)
'ARB])
(MAXANAL
[LAMBDA (VAL1 VAL2 FLG)
(IF }VAL1
THEN VAL2
ELSEIF }VAL2
THEN VAL1
ELSEIF VAL2='ARB or VAL1='ARB
THEN 'ARB
ELSEIF VAL1='SEG or VAL2='SEG
THEN 'SEG
ELSEIF FLG='SEGEXPR
THEN 'PLUS VAL1 VAL2
ELSEIF FLG
THEN ((NUMBERP VAL1) or 1)+((NUMBERP VAL2) or 1)
ELSEIF VAL1='ELT
THEN (IF VAL2=1 or VAL2='ELT
THEN VAL2
ELSE 'SEG)
ELSEIF VAL2='ELT
THEN (IF VAL1=1
THEN VAL1
ELSE 'SEG)
ELSE 'SEG])
(ANALPAT
[LAMBDA (PAT FLG FN TAIL)
(* Calls either ANALPATELT or FN on the elements of
PAT (up to TAIL) and returns the MAXANAL of them -
The value of FLG determinses whether MAXANAL returns
a sum or a maximum)
(PROG (VAL)
LP (IF PAT=TAIL or }PAT
THEN RETURN VAL)
(VAL←(MAXANAL (BLKAPPLY (OR FN 'ANALPATELT)
<PAT:1>)
VAL FLG))
(PAT←PAT::1)
(GO LP])
(ANALPATELT
[LAMBDA (PATELT SEGEXPR)
(* Analyze PATELT , returning either -
"ELT" if PATELT matches a single element -
"SEG" if PATELT matches a segment of fixed but not
given size -
A number if PATELT matches a segment of fixed, given
size -
Or "ARB" if PATELT matches a segment of not
precomputable size)
(* Unless SEGEXPR is on, in which case, the size of
the expr is returned instead of seg)
(* Also, if the PATELT is a "SET", sets special
variable "SETS" -
If it contains a match (i.e., other than $i's or $'s
or sets involving those) it sets the special
variable "MATCH")
(IF NLISTP PATELT
THEN (SELECTQ PATELT
(($1 &)
(IF SEGEXPR
THEN 1
ELSE 'ELT))
(("*" *)
SETS←T
(IF SEGEXPR
THEN 1
ELSE 'ELT))
(($ --)
'ARB)
(HELP '"FUNNY PAT IN ANALPATELT" PATELT))
ELSE (SELECTQ PATELT:1
(! (ABP PATELT SEGEXPR))
($$ (* Either $$ NUMBER or
$$ EXPRESSION)
(OR (NUMBERP PATELT::1)
(AND SEGEXPR PATELT::1)
'SEG))
(DEFAULT (ANALPATELT (MAKEDEFAULT PATELT)
SEGEXPR))
((= == ' :)
MATCH←T (* = FOO matches an
element)
(IF SEGEXPR
THEN 1
ELSE 'ELT))
(ANY (* It's the MAX of them
all)
(ANALPAT PATELT::1 (AND SEGEXPR 'SEGEXPR)))
(← (* It's a set, with the
same PROP as what's
being set)
SETS←T
(ANALPATELT PATELT::2 SEGEXPR))
(-> (* Ditto)
SETS←T
(ANALPATELT PATELT::2 SEGEXPR))
((!← !->)
SETS←T
0)
(PROGN (* Got a PATELT which is
a list of pats)
(ANALPAT PATELT)
(IF SEGEXPR
THEN 1
ELSE 'ELT])
(EQLENGTH
[LAMBDA (X N)
(AND (SETQ X (NTH X N))
(NULL (CDR X])
('LISTOFONE
[LAMBDA (X)
(LIST (QUOTE LISTOFONE)
X])
(LISTOFONE
[LAMBDA (X)
(AND X (NLISTP (CDR X])
(RPLNODE2
[LAMBDA (X Y)
(RPLACA (X::1←Y::1)
Y:1])
(ABP
[LAMBDA (PATELT SEGEXPR)
(IF NLISTP PATELT::1
THEN (SELECTQ PATELT::1
(("*" *) (* !* is like result←$)
SETS←T
'ARB)
(($1 &) (* !$1 is the same as $)
'ARB)
(HELP '"FUNNY NLISTP PAT AFTER ! IN" PATELT::1))
ELSE (SELECTQ PATELT:2
(' (* !'exp matches exactly
length exp things)
(LENGTH PATELT::2))
((= ==) (* = exp matches
precomputable NUMBER of
things)
MATCH←T
(* THIS ISWHAT USED TO BE HERE:
(COND (SEGEXPR ('LENGTH (CDR
(CDR PATELT)))) (T (QUOTE SEG))))
'ARB)
(: MATCH←T
'ARB)
((← ->)
SETS←T
(ABP PATELT::2 SEGEXPR))
(DEFAULT (* MAKEDEFAULT actually
smashes it, so go ahead
& try it again)
(MAKEDEFAULT PATELT::1)
(ABP PATELT SEGEXPR))
(ANY
(* ! (any ...) matches the MAX of ANAL!PAT of the
elts of the any)
(ANALPAT PATELT::2 (AND SEGEXPR 'SEGEXPR)
(FUNCTION ANAL!PAT)))
(IF }(PATELT::2)
THEN (IF LISTP PATELT:2
THEN (RPLNODE PATELT PATELT:2)
(ANALPATELT PATELT SEGEXPR)
ELSE ANALPATELT PATELT:2 SEGEXPR)
ELSE ANALPAT PATELT::1])
('CDRLEN
[LAMBDA (EXPR)
('NTH EXPR ('PLUS 1 LEN])
('MATCH&SET
[LAMBDA (EXPR PAT MATCHFN CDRFN VARTOSET)
(IF VARTOSET
THEN (IF T=VARTOSET
THEN ('AND ('SETQ TEM←(MAKEVAR T)
EXPR)
('AND (BLKAPPLY* MATCHFN
(IF CDRFN
THEN BLKAPPLY* CDRFN
TEM
ELSE TEM)
PAT)
TEM))
ELSEIF (LOCALPATVAR TEM←(MAKEVAR VARTOSET))
THEN ('AND ('SETQ TEM EXPR)
(BLKAPPLY* MATCHFN
(IF CDRFN
THEN BLKAPPLY* CDRFN TEM
ELSE TEM)
PAT))
ELSE (POSTPONE ('SETQ TEM TEM←(MAKEVAR T)))
('AND ('SETQ TEM EXPR)
('AND (BLKAPPLY* MATCHFN
(IF CDRFN
THEN BLKAPPLY* CDRFN TEM
ELSE TEM)
PAT)
TEM)))
ELSE (BLKAPPLY* MATCHFN
(IF CDRFN
THEN BLKAPPLY* CDRFN EXPR
ELSE EXPR)
PAT])
(LOCALPATVAR
[LAMBDA (VAR)
(SOME BINDINGS (FUNCTION (LAMBDA (X)
VAR=X OR VAR=X:1])
('MATCHEXP1
[LAMBDA (VAR PAT FN)
(COND
((EASYTORECOMPUTE VAR)
(BLKAPPLY* FN VAR PAT))
(T (PROG (EXPR (FUNNYTEM (GENSYML VAR)))
(SETQ EXPR (BLKAPPLY* FN FUNNYTEM PAT))
(COND
((OR (NULL EXPR)
(EQ EXPR T))
(SETQ EXPR FUNNYTEM)))
(SETQ EXPR (MAKESUBST FUNNYTEM VAR
(LIST EXPR POSTPONEDEFFECTS
MUSTRETURN)))
(SETQ POSTPONEDEFFECTS (CADR EXPR))
(SETQ MUSTRETURN (CADDR EXPR))
(RETURN (CAR EXPR])
('MATCHNNIL
[LAMBDA (VAR PAT) (* Match VAR against
PAT, with check that VAR
is not NIL)
(HELP)
('AND VAR ('MATCH VAR PAT])
('MATCHWITHMEMB
[LAMBDA (VAR PAT MUSTRETURNTAIL)
(AND (MEMBPAT? PAT)
('MATCH&SET (EQTOMEMB ('MATCHELT VAR PAT:1))
PAT:1←'$1
(FUNCTION 'MATCHEXP)
NIL MUSTRETURNTAIL])
('MATCHSOME
[LAMBDA (VAR PAT)
(PROG ((SOMEVARS (<(GENSYML VAR)
(GENSYML VAR)>))
(MUSTBEMATCH T))
('SOME VAR <SOMEVARS:1 SOMEVARS:2> (DSUBST SOMEVARS:1
('CAR SOMEVARS:2)
('MATCH SOMEVARS:2
PAT])
(MAKEMATCH
[LAMBDA (VAR TOPPAT)
('MATCHTOP VAR (PATPARSE (COPY TOPPAT])
('MATCHFIXED
[LAMBDA (VAR PAT)
(* This function is called when it is known that if
any element of VAR is non NIL, then VAR is of the
right length to MATCH PAT and so no length tests
need be performed)
(PROG (NULLCHK)
(IF }(EVERY PAT (FUNCTION CANMATCHNIL))
THEN 'MATCHEXP VAR PAT
ELSE ('MATCHEXP1 VAR PAT (FUNCTION 'MATCHNNIL])
('MATCHBIND
[LAMBDA (VAR PAT MUSTBEMATCH)
('MATCH VAR PAT])
)
(LISPXPRINT (QUOTE OLDMATCHFNS)
T)
(RPAQQ OLDMATCHFNS
(PACKLDIFF MAKE!DEFAULT PARSE 'LDIFF 'TAILP 'LENGTH
OPTIMIZEAND '!AND 'SOME 'SETVAR
'REPLACE←SIDE←EFFECT 'SETQ←SIDE←EFFECT MAKEVAR
BOUNDVAR BIND EQTOMEMB NOMATCHARBCAR? SUBPAT?
NOMATCHELT? NOMATCHARB? MEMBPAT? SKIP$ ANAL!PAT
MAXANAL ANALPAT ANALPATELT EQLENGTH 'LISTOFONE
LISTOFONE RPLNODE2 ABP 'CDRLEN 'MATCH&SET
LOCALPATVAR 'MATCHEXP1 'MATCHNNIL 'MATCHWITHMEMB
'MATCHSOME MAKEMATCH 'MATCHFIXED 'MATCHBIND))
(LISPXPRINT (QUOTE OLDMATCHVARS)
T)
(RPAQQ OLDMATCHVARS ((BLOCKS * OLDMATCHBLOCKS)))
[RPAQQ OLDMATCHBLOCKS
((MATCHBLOCK MAKEMATCH 'MATCHTOP 'MATCH 'MATCHBIND 'MATCHELT
'MATCHEXP 'MATCHFIXED 'MATCHSUBPAT 'MATCHTAIL
'MATCHSOME 'MATCHWITHMEMB 'MATCHNNIL 'MATCHEXP1
LOCALPATVAR 'MATCH&SET 'CDRLEN POSTPONE
NOMATCHELT? 'HEADP ANALPATELT ANALPAT MAXANAL
ANAL!PAT ABP $? SKIP$I SKIP$ SKIP$ANY ELT?
MEMBPAT? ARB? NOMATCHARB? SUBPAT? NOMATCHARBCAR?
NULLPAT? CANMATCHNIL EASYTORECOMPUTE EQTOMEMB
FULLEXPANSION GENSYML MAKESUBST MAKESUBST1
FORMEXPAND BIND BOUNDVAR RECOMPUTATION MAKEVAR
'NLEFT 'NOT 'NOTLESSPLENGTH 'NTH 'NTH{NUMBER⎇ 'OR
'PLUS 'REPLACE 'SETQ←SIDE←EFFECT
'REPLACE←SIDE←EFFECT 'SETQ 'SETVAR 'SOME 'AND
'!AND OPTIMIZEAND 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL
'LENGTH 'LISTP 'NULL 'LAST 'TAILP 'LDIFF 'RETURN
PARSE PATPARSE NUMPATPARSE PATPARSE1 PATPARSE←
BI12 PATPARSEAT PACKLDIFF BISET BIRPLAC
MAKEDEFAULT MAKE!DEFAULT
(BLKAPPLYFNS ANALPATELT ANAL!PAT 'MATCH
'MATCHNNIL 'MATCHFIXED 'MATCHEXP
'CDRLEN)
(ENTRIES MAKEMATCH)
(GLOBALVARS VARDEFAULT LISTPCHK ORSETQFLG
POSTPONE←SIDE←EFFECTS)
(LOCALFREEVARS TAIL TEM ISVALUE EASYFNS BINDINGS
MUSTBEMATCH POSTPONEDEFFECTS
MUSTRETURN SOMEVARS GENSYMVARSLIST
MAKESUBSTVARLIST MATCH SETS
NULLCHK TOPPAT FOUNDBEFORE LEN
GENSYMVARLIST OLD NEW SAVNEW TEM2]
(DECLARE
(BLOCK: MATCHBLOCK MAKEMATCH 'MATCHTOP 'MATCH 'MATCHBIND 'MATCHELT
'MATCHEXP 'MATCHFIXED 'MATCHSUBPAT 'MATCHTAIL 'MATCHSOME
'MATCHWITHMEMB 'MATCHNNIL 'MATCHEXP1 LOCALPATVAR 'MATCH&SET
'CDRLEN POSTPONE NOMATCHELT? 'HEADP ANALPATELT ANALPAT
MAXANAL ANAL!PAT ABP $? SKIP$I SKIP$ SKIP$ANY ELT? MEMBPAT?
ARB? NOMATCHARB? SUBPAT? NOMATCHARBCAR? NULLPAT? CANMATCHNIL
EASYTORECOMPUTE EQTOMEMB FULLEXPANSION GENSYML MAKESUBST
MAKESUBST1 FORMEXPAND BIND BOUNDVAR RECOMPUTATION MAKEVAR
'NLEFT 'NOT 'NOTLESSPLENGTH 'NTH 'NTH{NUMBER⎇ 'OR 'PLUS
'REPLACE 'SETQ←SIDE←EFFECT 'REPLACE←SIDE←EFFECT 'SETQ 'SETVAR
'SOME 'AND '!AND OPTIMIZEAND 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL
'LENGTH 'LISTP 'NULL 'LAST 'TAILP 'LDIFF 'RETURN PARSE
PATPARSE NUMPATPARSE PATPARSE1 PATPARSE← BI12 PATPARSEAT
PACKLDIFF BISET BIRPLAC MAKEDEFAULT MAKE!DEFAULT
(BLKAPPLYFNS ANALPATELT ANAL!PAT 'MATCH 'MATCHNNIL
'MATCHFIXED 'MATCHEXP 'CDRLEN)
(ENTRIES MAKEMATCH)
(GLOBALVARS VARDEFAULT LISTPCHK ORSETQFLG
POSTPONE←SIDE←EFFECTS)
(LOCALFREEVARS TAIL TEM ISVALUE EASYFNS BINDINGS MUSTBEMATCH
POSTPONEDEFFECTS MUSTRETURN SOMEVARS
GENSYMVARSLIST MAKESUBSTVARLIST MATCH SETS
NULLCHK TOPPAT FOUNDBEFORE LEN GENSYMVARLIST
OLD NEW SAVNEW TEM2))
)STOP